home *** CD-ROM | disk | FTP | other *** search
/ c't freeware shareware 2001 February / CT_SW0102.ISO / pc / software / entwickl / tools / maccvs.sit / MacCvs 3.1 Application / Tcl8.3.shlb.rsrc / TEXT_2002_Package.txt < prev    next >
Text File  |  2000-02-10  |  18KB  |  610 lines
  1. # package.tcl --
  2. #
  3. # utility procs formerly in init.tcl which can be loaded on demand
  4. # for package management.
  5. #
  6. # RCS: @(#) $Id: package.tcl,v 1.11 2000/02/07 22:33:17 ericm Exp $
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1998 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. # Create the package namespace
  16. namespace eval ::pkg {
  17. }
  18.  
  19. # pkg_compareExtension --
  20. #
  21. #  Used internally by pkg_mkIndex to compare the extension of a file to
  22. #  a given extension. On Windows, it uses a case-insensitive comparison
  23. #  because the file system can be file insensitive.
  24. #
  25. # Arguments:
  26. #  fileName    name of a file whose extension is compared
  27. #  ext        (optional) The extension to compare against; you must
  28. #        provide the starting dot.
  29. #        Defaults to [info sharedlibextension]
  30. #
  31. # Results:
  32. #  Returns 1 if the extension matches, 0 otherwise
  33.  
  34. proc pkg_compareExtension { fileName {ext {}} } {
  35.     global tcl_platform
  36.     if {[string length $ext] == 0} {
  37.     set ext [info sharedlibextension]
  38.     }
  39.     if {[string equal $tcl_platform(platform) "windows"]} {
  40.     return [string equal -nocase [file extension $fileName] $ext]
  41.     } else {
  42.     return [string equal [file extension $fileName] $ext]
  43.     }
  44. }
  45.  
  46. # pkg_mkIndex --
  47. # This procedure creates a package index in a given directory.  The
  48. # package index consists of a "pkgIndex.tcl" file whose contents are
  49. # a Tcl script that sets up package information with "package require"
  50. # commands.  The commands describe all of the packages defined by the
  51. # files given as arguments.
  52. #
  53. # Arguments:
  54. # -direct        (optional) If this flag is present, the generated
  55. #            code in pkgMkIndex.tcl will cause the package to be
  56. #            loaded when "package require" is executed, rather
  57. #            than lazily when the first reference to an exported
  58. #            procedure in the package is made.
  59. # -verbose        (optional) Verbose output; the name of each file that
  60. #            was successfully rocessed is printed out. Additionally,
  61. #            if processing of a file failed a message is printed.
  62. # -load pat        (optional) Preload any packages whose names match
  63. #            the pattern.  Used to handle DLLs that depend on
  64. #            other packages during their Init procedure.
  65. # dir -            Name of the directory in which to create the index.
  66. # args -        Any number of additional arguments, each giving
  67. #            a glob pattern that matches the names of one or
  68. #            more shared libraries or Tcl script files in
  69. #            dir.
  70.  
  71. proc pkg_mkIndex {args} {
  72.     global errorCode errorInfo
  73.     set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"};
  74.  
  75.     set argCount [llength $args]
  76.     if {$argCount < 1} {
  77.     return -code error "wrong # args: should be\n$usage"
  78.     }
  79.  
  80.     set more ""
  81.     set direct 1
  82.     set doVerbose 0
  83.     set loadPat ""
  84.     for {set idx 0} {$idx < $argCount} {incr idx} {
  85.     set flag [lindex $args $idx]
  86.     switch -glob -- $flag {
  87.         -- {
  88.         # done with the flags
  89.         incr idx
  90.         break
  91.         }
  92.         -verbose {
  93.         set doVerbose 1
  94.         }
  95.         -lazy {
  96.         set direct 0
  97.         append more " -lazy"
  98.         }
  99.         -direct {
  100.         append more " -direct"
  101.         }
  102.         -load {
  103.         incr idx
  104.         set loadPat [lindex $args $idx]
  105.         append more " -load $loadPat"
  106.         }
  107.         -* {
  108.         return -code error "unknown flag $flag: should be\n$usage"
  109.         }
  110.         default {
  111.         # done with the flags
  112.         break
  113.         }
  114.     }
  115.     }
  116.  
  117.     set dir [lindex $args $idx]
  118.     set patternList [lrange $args [expr {$idx + 1}] end]
  119.     if {[llength $patternList] == 0} {
  120.     set patternList [list "*.tcl" "*[info sharedlibextension]"]
  121.     }
  122.  
  123.     set oldDir [pwd]
  124.     cd $dir
  125.  
  126.     if {[catch {eval glob $patternList} fileList]} {
  127.     global errorCode errorInfo
  128.     cd $oldDir
  129.     return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
  130.     }
  131.     foreach file $fileList {
  132.     # For each file, figure out what commands and packages it provides.
  133.     # To do this, create a child interpreter, load the file into the
  134.     # interpreter, and get a list of the new commands and packages
  135.     # that are defined.
  136.  
  137.     if {[string equal $file "pkgIndex.tcl"]} {
  138.         continue
  139.     }
  140.  
  141.     # Changed back to the original directory before initializing the
  142.     # slave in case TCL_LIBRARY is a relative path (e.g. in the test
  143.     # suite). 
  144.  
  145.     cd $oldDir
  146.     set c [interp create]
  147.  
  148.     # Load into the child any packages currently loaded in the parent
  149.     # interpreter that match the -load pattern.
  150.  
  151.     foreach pkg [info loaded] {
  152.         if {! [string match $loadPat [lindex $pkg 1]]} {
  153.         continue
  154.         }
  155.         if {[string equal [lindex $pkg 1] "Tk"]} {
  156.         $c eval {set argv {-geometry +0+0}}
  157.         }
  158.         if {[catch {
  159.         load [lindex $pkg 0] [lindex $pkg 1] $c
  160.         } err]} {
  161.         if {$doVerbose} {
  162.             tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
  163.         }
  164.         } elseif {$doVerbose} {
  165.         tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
  166.         }
  167.     }
  168.     cd $dir
  169.  
  170.     $c eval {
  171.         # Stub out the package command so packages can
  172.         # require other packages.
  173.  
  174.         rename package __package_orig
  175.         proc package {what args} {
  176.         switch -- $what {
  177.             require { return ; # ignore transitive requires }
  178.             default { eval __package_orig {$what} $args }
  179.         }
  180.         }
  181.         proc tclPkgUnknown args {}
  182.         package unknown tclPkgUnknown
  183.  
  184.         # Stub out the unknown command so package can call
  185.         # into each other during their initialilzation.
  186.  
  187.         proc unknown {args} {}
  188.  
  189.         # Stub out the auto_import mechanism
  190.  
  191.         proc auto_import {args} {}
  192.  
  193.         # reserve the ::tcl namespace for support procs
  194.         # and temporary variables.  This might make it awkward
  195.         # to generate a pkgIndex.tcl file for the ::tcl namespace.
  196.  
  197.         namespace eval ::tcl {
  198.         variable file        ;# Current file being processed
  199.         variable direct        ;# -direct flag value
  200.         variable x        ;# Loop variable
  201.         variable debug        ;# For debugging
  202.         variable type        ;# "load" or "source", for -direct
  203.         variable namespaces    ;# Existing namespaces (e.g., ::tcl)
  204.         variable packages    ;# Existing packages (e.g., Tcl)
  205.         variable origCmds    ;# Existing commands
  206.         variable newCmds    ;# Newly created commands
  207.         variable newPkgs {}    ;# Newly created packages
  208.         }
  209.     }
  210.  
  211.     $c eval [list set ::tcl::file $file]
  212.     $c eval [list set ::tcl::direct $direct]
  213.  
  214.     # Download needed procedures into the slave because we've
  215.     # just deleted the unknown procedure.  This doesn't handle
  216.     # procedures with default arguments.
  217.  
  218.     foreach p {pkg_compareExtension} {
  219.         $c eval [list proc $p [info args $p] [info body $p]]
  220.     }
  221.  
  222.     if {[catch {
  223.         $c eval {
  224.         set ::tcl::debug "loading or sourcing"
  225.  
  226.         # we need to track command defined by each package even in
  227.         # the -direct case, because they are needed internally by
  228.         # the "partial pkgIndex.tcl" step above.
  229.  
  230.         proc ::tcl::GetAllNamespaces {{root ::}} {
  231.             set list $root
  232.             foreach ns [namespace children $root] {
  233.             eval lappend list [::tcl::GetAllNamespaces $ns]
  234.             }
  235.             return $list
  236.         }
  237.  
  238.         # init the list of existing namespaces, packages, commands
  239.  
  240.         foreach ::tcl::x [::tcl::GetAllNamespaces] {
  241.             set ::tcl::namespaces($::tcl::x) 1
  242.         }
  243.         foreach ::tcl::x [package names] {
  244.             set ::tcl::packages($::tcl::x) 1
  245.         }
  246.         set ::tcl::origCmds [info commands]
  247.  
  248.         # Try to load the file if it has the shared library
  249.         # extension, otherwise source it.  It's important not to
  250.         # try to load files that aren't shared libraries, because
  251.         # on some systems (like SunOS) the loader will abort the
  252.         # whole application when it gets an error.
  253.  
  254.         if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
  255.             # The "file join ." command below is necessary.
  256.             # Without it, if the file name has no \'s and we're
  257.             # on UNIX, the load command will invoke the
  258.             # LD_LIBRARY_PATH search mechanism, which could cause
  259.             # the wrong file to be used.
  260.  
  261.             set ::tcl::debug loading
  262.             load [file join . $::tcl::file]
  263.             set ::tcl::type load
  264.         } else {
  265.             set ::tcl::debug sourcing
  266.             source $::tcl::file
  267.             set ::tcl::type source
  268.         }
  269.  
  270.         # As a performance optimization, if we are creating 
  271.         # direct load packages, don't bother figuring out the 
  272.         # set of commands created by the new packages.  We 
  273.         # only need that list for setting up the autoloading 
  274.         # used in the non-direct case.
  275.         if { !$::tcl::direct } {
  276.             # See what new namespaces appeared, and import commands
  277.             # from them.  Only exported commands go into the index.
  278.             
  279.             foreach ::tcl::x [::tcl::GetAllNamespaces] {
  280.             if {! [info exists ::tcl::namespaces($::tcl::x)]} {
  281.                 namespace import -force ${::tcl::x}::*
  282.             }
  283.  
  284.             # Figure out what commands appeared
  285.             
  286.             foreach ::tcl::x [info commands] {
  287.                 set ::tcl::newCmds($::tcl::x) 1
  288.             }
  289.             foreach ::tcl::x $::tcl::origCmds {
  290.                 catch {unset ::tcl::newCmds($::tcl::x)}
  291.             }
  292.             foreach ::tcl::x [array names ::tcl::newCmds] {
  293.                 # determine which namespace a command comes from
  294.                 
  295.                 set ::tcl::abs [namespace origin $::tcl::x]
  296.                 
  297.                 # special case so that global names have no leading
  298.                 # ::, this is required by the unknown command
  299.                 
  300.                 set ::tcl::abs \
  301.                     [lindex [auto_qualify $::tcl::abs ::] 0]
  302.                 
  303.                 if {[string compare $::tcl::x $::tcl::abs]} {
  304.                 # Name changed during qualification
  305.                 
  306.                 set ::tcl::newCmds($::tcl::abs) 1
  307.                 unset ::tcl::newCmds($::tcl::x)
  308.                 }
  309.             }
  310.             }
  311.         }
  312.  
  313.         # Look through the packages that appeared, and if there is
  314.         # a version provided, then record it
  315.  
  316.         foreach ::tcl::x [package names] {
  317.             if {[string compare [package provide $::tcl::x] ""] \
  318.                 && ![info exists ::tcl::packages($::tcl::x)]} {
  319.             lappend ::tcl::newPkgs \
  320.                 [list $::tcl::x [package provide $::tcl::x]]
  321.             }
  322.         }
  323.         }
  324.     } msg] == 1} {
  325.         set what [$c eval set ::tcl::debug]
  326.         if {$doVerbose} {
  327.         tclLog "warning: error while $what $file: $msg"
  328.         }
  329.     } else {
  330.         set type [$c eval set ::tcl::type]
  331.         set cmds [lsort [$c eval array names ::tcl::newCmds]]
  332.         set pkgs [$c eval set ::tcl::newPkgs]
  333.         if {[llength $pkgs] > 1} {
  334.         tclLog "warning: \"$file\" provides more than one package ($pkgs)"
  335.         }
  336.         foreach pkg $pkgs {
  337.         # cmds is empty/not used in the direct case
  338.         lappend files($pkg) [list $file $type $cmds]
  339.         }
  340.  
  341.         if {$doVerbose} {
  342.         tclLog "processed $file"
  343.         }
  344.         interp delete $c
  345.     }
  346.     }
  347.  
  348.     append index "# Tcl package index file, version 1.1\n"
  349.     append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
  350.     append index "# and sourced either when an application starts up or\n"
  351.     append index "# by a \"package unknown\" script.  It invokes the\n"
  352.     append index "# \"package ifneeded\" command to set up package-related\n"
  353.     append index "# information so that packages will be loaded automatically\n"
  354.     append index "# in response to \"package require\" commands.  When this\n"
  355.     append index "# script is sourced, the variable \$dir must contain the\n"
  356.     append index "# full path name of this file's directory.\n"
  357.  
  358.     foreach pkg [lsort [array names files]] {
  359.     set cmd {}
  360.     foreach {name version} $pkg {
  361.         break
  362.     }
  363.     lappend cmd ::pkg::create -name $name -version $version
  364.     foreach spec $files($pkg) {
  365.         foreach {file type procs} $spec {
  366.         if { $direct } {
  367.             set procs {}
  368.         }
  369.         lappend cmd "-$type" [list $file $procs]
  370.         }
  371.     }
  372.     append index "\n[eval $cmd]"
  373.     }
  374.  
  375.     set f [open pkgIndex.tcl w]
  376.     puts $f $index
  377.     close $f
  378.     cd $oldDir
  379. }
  380.  
  381. # tclPkgSetup --
  382. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  383. # as part of a "package ifneeded" script.  It calls "package provide"
  384. # to indicate that a package is available, then sets entries in the
  385. # auto_index array so that the package's files will be auto-loaded when
  386. # the commands are used.
  387. #
  388. # Arguments:
  389. # dir -            Directory containing all the files for this package.
  390. # pkg -            Name of the package (no version number).
  391. # version -        Version number for the package, such as 2.1.3.
  392. # files -        List of files that constitute the package.  Each
  393. #            element is a sub-list with three elements.  The first
  394. #            is the name of a file relative to $dir, the second is
  395. #            "load" or "source", indicating whether the file is a
  396. #            loadable binary or a script to source, and the third
  397. #            is a list of commands defined by this file.
  398.  
  399. proc tclPkgSetup {dir pkg version files} {
  400.     global auto_index
  401.  
  402.     package provide $pkg $version
  403.     foreach fileInfo $files {
  404.     set f [lindex $fileInfo 0]
  405.     set type [lindex $fileInfo 1]
  406.     foreach cmd [lindex $fileInfo 2] {
  407.         if {[string equal $type "load"]} {
  408.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  409.         } else {
  410.         set auto_index($cmd) [list source [file join $dir $f]]
  411.         } 
  412.     }
  413.     }
  414. }
  415.  
  416. # tclMacPkgSearch --
  417. # The procedure is used on the Macintosh to search a given directory for files
  418. # with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
  419. # interpreter to setup the package database.
  420.  
  421. proc tclMacPkgSearch {dir} {
  422.     foreach x [glob -nocomplain [file join $dir *.shlb]] {
  423.     if {[file isfile $x]} {
  424.         set res [resource open $x]
  425.         foreach y [resource list TEXT $res] {
  426.         if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
  427.         }
  428.         catch {resource close $res}
  429.     }
  430.     }
  431. }
  432.  
  433. # tclPkgUnknown --
  434. # This procedure provides the default for the "package unknown" function.
  435. # It is invoked when a package that's needed can't be found.  It scans
  436. # the auto_path directories and their immediate children looking for
  437. # pkgIndex.tcl files and sources any such files that are found to setup
  438. # the package database.  (On the Macintosh we also search for pkgIndex
  439. # TEXT resources in all files.)
  440. #
  441. # Arguments:
  442. # name -        Name of desired package.  Not used.
  443. # version -        Version of desired package.  Not used.
  444. # exact -        Either "-exact" or omitted.  Not used.
  445.  
  446. proc tclPkgUnknown {name version {exact {}}} {
  447.     global auto_path tcl_platform env
  448.  
  449.     if {![info exists auto_path]} {
  450.     return
  451.     }
  452.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  453.     # we can't use glob in safe interps, so enclose the following
  454.     # in a catch statement
  455.     catch {
  456.         foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
  457.             * pkgIndex.tcl]] {
  458.         set dir [file dirname $file]
  459.         if {[file readable $file]} {
  460.             if {[catch {source $file} msg]} {
  461.             tclLog "error reading package index file $file: $msg"
  462.             }
  463.         }
  464.         }
  465.     }
  466.     set dir [lindex $auto_path $i]
  467.     set file [file join $dir pkgIndex.tcl]
  468.     # safe interps usually don't have "file readable", nor stderr channel
  469.     if {[interp issafe] || [file readable $file]} {
  470.         if {[catch {source $file} msg] && ![interp issafe]}  {
  471.         tclLog "error reading package index file $file: $msg"
  472.         }
  473.     }
  474.     # On the Macintosh we also look in the resource fork 
  475.     # of shared libraries
  476.     # We can't use tclMacPkgSearch in safe interps because it uses glob
  477.     if {(![interp issafe]) && \
  478.         [string equal $tcl_platform(platform) "macintosh"]} {
  479.         set dir [lindex $auto_path $i]
  480.         tclMacPkgSearch $dir
  481.         foreach x [glob -nocomplain [file join $dir *]] {
  482.         if {[file isdirectory $x]} {
  483.             set dir $x
  484.             tclMacPkgSearch $dir
  485.         }
  486.         }
  487.     }
  488.     }
  489. }
  490.  
  491. # ::pkg::create --
  492. #
  493. #    Given a package specification generate a "package ifneeded" statement
  494. #    for the package, suitable for inclusion in a pkgIndex.tcl file.
  495. #
  496. # Arguments:
  497. #    args        arguments used by the create function:
  498. #            -name        packageName
  499. #            -version    packageVersion
  500. #            -load        {filename ?{procs}?}
  501. #            ...
  502. #            -source        {filename ?{procs}?}
  503. #            ...
  504. #
  505. #            Any number of -load and -source parameters may be
  506. #            specified, so long as there is at least one -load or
  507. #            -source parameter.  If the procs component of a 
  508. #            module specifier is left off, that module will be
  509. #            set up for direct loading; otherwise, it will be
  510. #            set up for lazy loading.  If both -source and -load
  511. #            are specified, the -load'ed files will be loaded 
  512. #            first, followed by the -source'd files.
  513. #
  514. # Results:
  515. #    An appropriate "package ifneeded" statement for the package.
  516.  
  517. proc ::pkg::create {args} {
  518.     append err(usage) "[lindex [info level 0] 0] "
  519.     append err(usage) "-name packageName -version packageVersion"
  520.     append err(usage) "?-load {filename ?{procs}?}? ... "
  521.     append err(usage) "?-source {filename ?{procs}?}? ..."
  522.  
  523.     set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
  524.     set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
  525.     set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
  526.     set err(noLoadOrSource) "at least one of -load and -source must be given"
  527.  
  528.     # process arguments
  529.     set len [llength $args]
  530.     if { $len < 6 } {
  531.     error $err(wrongNumArgs)
  532.     }
  533.     
  534.     # Initialize parameters
  535.     set opts(-name)        {}
  536.     set opts(-version)        {}
  537.     set opts(-source)        {}
  538.     set opts(-load)        {}
  539.  
  540.     # process parameters
  541.     for {set i 0} {$i < $len} {incr i} {
  542.     set flag [lindex $args $i]
  543.     incr i
  544.     switch -glob -- $flag {
  545.         "-name"        -
  546.         "-version"        {
  547.         if { $i >= $len } {
  548.             error [format $err(valueMissing) $flag]
  549.         }
  550.         set opts($flag) [lindex $args $i]
  551.         }
  552.         "-source"        -
  553.         "-load"        {
  554.         if { $i >= $len } {
  555.             error [format $err(valueMissing) $flag]
  556.         }
  557.         lappend opts($flag) [lindex $args $i]
  558.         }
  559.         default {
  560.         error [format $err(unknownOpt) [lindex $args $i]]
  561.         }
  562.     }
  563.     }
  564.  
  565.     # Validate the parameters
  566.     if { [llength $opts(-name)] == 0 } {
  567.     error [format $err(valueMissing) "-name"]
  568.     }
  569.     if { [llength $opts(-version)] == 0 } {
  570.     error [format $err(valueMissing) "-version"]
  571.     }
  572.     
  573.     if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
  574.     error $err(noLoadOrSource)
  575.     }
  576.  
  577.     # OK, now everything is good.  Generate the package ifneeded statment.
  578.     set cmdline "package ifneeded $opts(-name) $opts(-version) "
  579.     
  580.     set cmdList {}
  581.     set lazyFileList {}
  582.  
  583.     # Handle -load and -source specs
  584.     foreach key {load source} {
  585.     foreach filespec $opts(-$key) {
  586.         foreach {filename proclist} {{} {}} {
  587.         break
  588.         }
  589.         foreach {filename proclist} $filespec {
  590.         break
  591.         }
  592.         
  593.         if { [llength $proclist] == 0 } {
  594.         set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
  595.         lappend cmdList $cmd
  596.         } else {
  597.         lappend lazyFileList [list $filename $key $proclist]
  598.         }
  599.     }
  600.     }
  601.  
  602.     if { [llength $lazyFileList] > 0 } {
  603.     lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
  604.         $opts(-version) [list $lazyFileList]\]"
  605.     }
  606.     append cmdline [join $cmdList "\\n"]
  607.     return $cmdline
  608. }
  609.  
  610.